home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / movie-window-w⁄controller.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  4.5 KB  |  118 lines  |  [TEXT/CCL2]
  1. ;
  2. ;    movie-window-with-controller.lisp    Wed, 29 Jun, 1994
  3. ;
  4. ;    A simple QuickTimeª movie player using the Movie Controller component.
  5. ;
  6. ;    This code requires System 7.0 or later. To be exact, get-movie function
  7. ;    has the dependency. If you use System6, get movie resource in another
  8. ;    way and pass it to make-instance with :movie initarg.
  9. ;
  10. ;    Masaya UEDA
  11. ;    ueda@shpcs.sharp.co.jp
  12.  
  13. (defclass movie-window (window)
  14.   ((movie :initarg :movie :accessor movie)
  15.    (mcplay :initform nil :accessor mcplay))
  16.   (:default-initargs :movie nil :color-p t :window-show nil
  17.     :window-type :document :window-title "Movie"))
  18.  
  19. ; ---
  20.  
  21. (defun gestalt (selector)
  22.   (rlet ((result :signed-long))
  23.     (if (= (#_gestalt selector result) #$noErr)
  24.       (%get-long result)
  25.       nil)))
  26.  
  27. (defun error-dialog (message &rest r)
  28.   (catch-cancel
  29.     (apply #'message-dialog
  30.            (concatenate 'string "Error: " message) r)))
  31.  
  32. (defun check-movie-error (message &rest r)
  33.   (unless (= (#_GetMoviesError) #$noErr)
  34.     (apply #'error-dialog message r)))
  35.  
  36. (defun init-system ()
  37.   (if (gestalt #$gestaltQuickTime)
  38.     (#_EnterMovies)
  39.     (error-dialog "QuickTime is not installed!")))
  40.  
  41. (defun get-movie ()
  42.   (rlet ((m :pointer) (movie-res-file :signed-integer)  (file-types :SFTypeList)
  43.          (reply :StandardFileReply) (resID :signed-integer 0) (was-changed :boolean))
  44.     (rset file-types (SFTypeList.array 0) "MooV")
  45.     (#_StandardGetFilePreview (%null-ptr) 1 file-types reply)
  46.     (when (rref reply :StandardFileReply.sfGood)
  47.       (#_OpenMovieFile (rref reply :StandardFileReply.sfFile) movie-res-file #$fsRdPerm)
  48.       (unless (check-movie-error "Could not open the file.")
  49.         (unwind-protect
  50.           (progn
  51.             (#_NewMovieFromFile m (%get-word movie-res-file) resID
  52.                                 (%null-ptr) #$newMovieActive was-changed)
  53.             (unless (check-movie-error "Could not get new moview from the file.")
  54.               (return-from get-movie (%get-ptr m))))
  55.           (#_CloseMovieFile (%get-word movie-res-file))
  56.           (check-movie-error "Could not close the file."))))))
  57.  
  58. (defmethod setup-movie ((mvwnd movie-window))
  59.   (with-accessors ((movie movie) (mcplay mcplay)) mvwnd
  60.     (rlet ((movie-box :rect) (controller-box :rect))
  61.       (#_GetMovieBox movie movie-box)
  62.       (#_OffsetRect :ptr movie-box :long (make-point (- (rref movie-box :rect.left))
  63.                                                      (- (rref movie-box :rect.top))))
  64.       (#_SetMovieBox movie movie-box)
  65.       (unless (check-movie-error "SetMovieBox failed.")
  66.         (setf mcplay (#_NewMovieController movie
  67.                                            (rref (wptr mvwnd) :WindowRecord.PortRect)
  68.                                            #$mcTopLeftMovie))
  69.         (cond  ((%null-ptr-p mcplay)
  70.                 (error-dialog "Could not get controller for movie with MCNewMovieController.")
  71.                 (setf mcplay nil))
  72.                (t (#_MCGetControllerBoundsRect mcplay controller-box)
  73.                   (unless (check-movie-error "Could not get controller bounds rect.")
  74.                     (#_UnionRect movie-box controller-box movie-box)
  75.                     (set-view-size mvwnd
  76.                                    (subtract-points (rref movie-box :rect.bottomright)
  77.                                                     (rref movie-box :rect.topleft)))
  78.                     (= (#_MCSetControllerPort (mcplay mvwnd) (wptr mvwnd)) #$noErr))))))))
  79.  
  80. ; ---
  81.  
  82. (defmethod initialize-instance :after ((mvwnd movie-window) &rest r)
  83.   (declare (ignore r))
  84.   (when (= (init-system) #$noErr)
  85.     (with-accessors ((movie movie)) mvwnd
  86.       (when (or movie (setf movie (get-movie)))
  87.         (when (setup-movie mvwnd)
  88.           (window-select mvwnd)
  89.           (return-from initialize-instance)))
  90.       (#_ExitMovies)))
  91.   (window-close mvwnd))
  92.  
  93. (defmethod window-close :after ((mvwnd movie-window))
  94.   (if (movie mvwnd)
  95.     (#_DisposeMovie (movie mvwnd)))
  96.   (if (mcplay mvwnd)
  97.     (#_CloseComponent (mcplay mvwnd)))
  98.   (#_ExitMovies))
  99.  
  100. (defmethod view-draw-contents :after ((mvwnd movie-window))
  101.   (#_MCDraw (mcplay mvwnd) (wptr mvwnd)))
  102.  
  103. (defmethod view-click-event-handler :around ((mvwnd movie-window) where)
  104.   (declare (ignore where))
  105.   (if (zerop (#_MCIsPlayerEvent (mcplay mvwnd) *current-event*))
  106.     (call-next-method)))
  107.  
  108. (defmethod window-null-event-handler :around ((mvwnd movie-window))
  109.   (if (zerop (#_MCIsPlayerEvent (mcplay mvwnd) *current-event*))
  110.     (call-next-method)))
  111.  
  112. #|
  113. (make-instance 'movie-window)
  114.  
  115. (unwind-protect (progn (#_EnterMovies)
  116.                        (make-instance 'movie-window :movie (get-movie)))
  117.            (#_ExitMovies))
  118. |#